Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Snippets/PNL Libraries/MyOOAbout.p

Text File | 1997-03-25 | 10.8 KB | 452 lines | [TEXT/CWIE]

unit MyOOAbout;

interface

    uses
        Types;

    type
        GetAboutStringProc = function (index: integer): Str255;

    const
        kAboutStringLongVersion = 0;
        kAboutStringShortVersion = 1;
        kAboutStringName = 2;
        kAboutStringThanks = 3;

    procedure StartupAbout;
    procedure ConfigureAbout( get_about_string_proc: GetAboutStringProc );
    procedure UpdateAboutBox;
    procedure OpenAboutBox;
    procedure CloseAboutBox;
    function DefaultGetAboutString (index: integer): Str255;

implementation

    uses
        Memory, Fonts, TextEdit, Resources, Icons,Quickdraw, Windows, TextUtils, Dialogs, AppleEvents,
        Events,
        MyMenus, MyDialogs, MyStrings, MyVersionResource, MySystemGlobals, MyWindows, MyAssertions,
        MyFMenus, AERegistry, MyAEUtils, AEObjects, MyStrh, MyUtils, MyTypes, MyStartup, MyOOMenus,
        MyRecordedMenuCommands, MyOOMainLoop, MyLowLevel, MyResources, MySystemGlobals, MyMathUtils,
        MyRegions, MyProcesses, MyErrors, MyInternetConfig,
        BaseGlobals;

    const
        agwtAbout = '•About';

    const
        about_id = 928;
        thanks_strh_id = 929;
        about_error_strh_id = 930;
        kThanksURL = 'thank:';
        kRegisterURL = 'register:';
        kICONStyledString = 'ICON:';

    type
        AboutObject = object(DObject)
                procedure Create (id: integer);
                override;
                procedure DoItem (item: integer);
                override;
                procedure DrawUserItem( item: integer );
                override;
                procedure DrawDisplayItem( item: integer; selected: boolean );
                function TrackGroup( group:integer ):boolean;
            end;

    type
        AboutDataEntry = record
            display: Str255;
            group: integer;
            url: Str255;
        end;

    const
        kNoGroup = 0;

{$ifc do_debug}
    var
        startup_check: integer;
{$endc}

    var
        about_data: Handle;
        about_data_count: longint;
        gGetAboutString: GetAboutStringProc;
        thanks_click_count: longint;
        about_object: AboutObject;

    procedure NextAboutDataEntry( var p: longint );
    begin
        Assert( about_data <> nil );
        Assert( (0 <= p) & (p < GetHandleSize( about_data )) );
        p := p + GetUnsignedByte( about_data^, p ) + 1; { display }
        p := p + 1; { group }
        p := p + GetUnsignedByte( about_data^, p ) + 1; { url }
        Assert( p <= GetHandleSize( about_data ) );
    end;

    procedure GetAboutDataEntry( index: integer; var entry: AboutDataEntry );
        var
            p: longint;
            i: integer;
    begin
        Assert( about_data <> nil );
        Assert( (1 <= index) & (index <= about_data_count) );
        p := 0;
        for i := 1 to index-1 do begin
            NextAboutDataEntry( p );
        end;
        Assert( p < GetHandleSize( about_data ) );
        BlockMoveData( AddPtrLong( about_data^, p ), @entry.display, GetUnsignedByte( about_data^, p ) + 1 );
        p := p + GetUnsignedByte( about_data^, p ) + 1;
        entry.group := GetUnsignedByte( about_data^, p );
        p := p + 1;
        BlockMoveData( AddPtrLong( about_data^, p ), @entry.url, GetUnsignedByte( about_data^, p ) + 1 );
        p := p + GetUnsignedByte( about_data^, p ) + 1;
    end;

    function MGetAboutData: OSErr;

        function CountAboutDataEntries: integer;
            var
                size: longint;
                count: integer;
                p: longint;
        begin
            Assert( about_data <> nil );
            p := 0;
            count := 0;
            size := GetHandleSize( about_data );
            while p < size do begin
                NextAboutDataEntry( p );
                Inc(count);
            end;
            Assert( p = size );
            CountAboutDataEntries := count;
        end;

        var
            err: OSErr;
    begin
        err := MGetResource( app_resfile, 'ABOU', about_id, about_data );
        Assert( err = noErr );
        if err = noErr then begin
            about_data_count := CountAboutDataEntries;
        end;
        MGetAboutData := err;
    end;

    procedure GetFirstGroupEntry( group: integer; var entry: AboutDataEntry );
        var
            i: integer;
    begin
        Assert( group <> 0 );
        for i := 1 to about_data_count do begin
            GetAboutDataEntry( i, entry );
            if entry.group = group then begin
                Exit( GetFirstGroupEntry );
            end;
        end;
        Assert( false );
    end;

{$ifc do_debug}
    procedure ValidateAboutEntryData;
        var
            i: integer;
            kind: integer;
            entry: AboutDataEntry;
            frame: Rect;
            first_of_group_entry: AboutDataEntry;
    begin
        Assert( about_object <> nil );
        Assert( about_data <> nil );
        for i := 1 to about_data_count do begin
            GetDItemKind( about_object.window, i, kind );
            GetAboutDataEntry( i, entry );
            if entry.group = kNoGroup then begin
                Assert( kind = userItem+itemDisable );
                Assert( entry.url = '' );
            end else begin
                Assert( kind = userItem );
                GetFirstGroupEntry( entry.group, first_of_group_entry );
                Assert( first_of_group_entry.url <> '' );
                if entry.display <> first_of_group_entry.display then begin { hack test to see if they are different entries }
                    Assert( entry.url = '' );
                end;
            end;
            if IsPrefix( entry.display, kICONStyledString ) then begin
                GetDItemRect( about_object.window, i, frame );
                Assert( (frame.right - frame.left = 32) & (frame.bottom - frame.top = 32) );
            end;
        end;
    end;
{$endc}

    var
        last_thanks_click_count: longint;
        random_thanks_index: integer;

    function DefaultGetAboutString (index: integer): Str255;
        var
            vers: versionRecord;
            newrti: integer;
            s: Str255;
    begin
        GetVersion(app_resfile, vers);
        case index of
            kAboutStringLongVersion: begin
                DefaultGetAboutString := vers.longVersion;
            end;
            kAboutStringShortVersion: begin
                DefaultGetAboutString := vers.shortVersion;
            end;
            kAboutStringName: begin
                DefaultGetAboutString := vers.name;
            end;
            kAboutStringThanks: begin
                if last_thanks_click_count <> thanks_click_count then begin
                    if CountStrs(thanks_strh_id) <= 1 then begin
                        random_thanks_index := 1;
                    end else begin
                        newrti := BAND(Random, $7FFF) mod (CountStrs(thanks_strh_id) - 1) + 1;
                        if newrti >= random_thanks_index then begin
                            Inc(newrti);
                        end;
                        random_thanks_index := newrti;
                    end;
                    last_thanks_click_count := thanks_click_count;
                end;
                GetIndString(s, thanks_strh_id, random_thanks_index);
                DefaultGetAboutString := s;
            end;
            otherwise begin
{                Assert( false );}
                DefaultGetAboutString := '???';
            end;
        end;
    end;

    function AboutObject.TrackGroup( group:integer ):boolean;
        var
            click_rgn:RgnHandle;

        procedure DrawItems( selected: boolean );
            var
                i: integer;
                entry: AboutDataEntry;
        begin
            for i := 1 to about_data_count do begin
                GetAboutDataEntry( i, entry );
                if entry.group = group then begin
                    DrawDisplayItem( i, selected );
                end;
            end;
        end;

        var
            inside,newinside:boolean;
            mouse:Point;
            i: integer;
            entry: AboutDataEntry;
            frame: Rect;
    begin
        SetPort( window );
        click_rgn := NewRgn;
        for i := 1 to about_data_count do begin
            GetAboutDataEntry( i, entry );
            if entry.group = group then begin
                GetDItemRect( window, i, frame );
                UnionRgnRect( click_rgn, frame );
            end;
        end;
        DrawItems( true );
        inside := true;
        while StillDown do begin
            GetMouse(mouse);
            newinside := PtInRgn( mouse, click_rgn );
            if newinside <> inside then begin
                DrawItems( newinside );
                inside := newinside;
            end;
        end;
        if inside then begin
            DrawItems( false );
        end;
        TrackGroup := inside;
    end;

    procedure AboutObject.DoItem (item: integer);
        var
            frame: Rect;
            entry: AboutDataEntry;
            err: OSErr;
    begin
        GetAboutDataEntry( item, entry );
        Assert( entry.group <> kNoGroup );
        GetFirstGroupEntry( entry.group, entry );
        Assert( entry.url <> '' );
        if entry.url = kThanksURL then begin
            Inc( thanks_click_count );
            GetDItemRect( window, item, frame );
            SetPort( window );
            InvalRect( frame );
        end else begin
            if TrackGroup( entry.group ) then begin
                if entry.url = kRegisterURL then begin
                    err := LaunchAppWithHint( app_fs.vRefNum, app_fs.parID, 'Regi','APPL',true );
                end else begin
                    err := MyLaunchURL( '', entry.url );
                end;
                if err <> noErr then begin
                    DisplayErrorString( GetIndStr( about_error_strh_id, 1 ), err );
                end;
            end;
        end;
    end;

    procedure AboutObject.DrawDisplayItem( item: integer; selected: boolean );
        var
            s, t: Str255;
            i, n: integer;
            entry: AboutDataEntry;
            id: longint;
            frame: Rect;
    begin
        SetPort( window );
        GetAboutDataEntry( item, entry );
        Assert( entry.display <> '' );
        s := entry.display;
        if IsPrefix( s, kICONStyledString ) then begin
            Delete( s, 1, length(kICONStyledString) );
            StringToNum( s, id );
            GetDItemRect( window, item, frame );
            SafePlotCIcon( id, frame, selected );
        end else begin
            i := 1;
            while (i < length(s)) do begin
                if s[i] = '^' then begin
                    n := ord(s[i+1])-48;
                    if n>= 10 then begin
                        n := n-7;
                    end;
                    t := gGetAboutString(n);
                    Delete(s, i, 2);
                    Insert(t, s, i);
                    i := i + length(t);
                end else begin
                    i := i + 1;
                end;
            end;
            DisplayStyledString( window, item, s, selected );
        end;
    end;

    procedure AboutObject.DrawUserItem( item: integer );
    begin
        DrawDisplayItem( item, false );
    end;

    procedure AboutObject.Create (id: integer);
        var
            s: Str255;
            vers: versionRecord;
    begin
        UseResFile(app_resfile);
        inherited Create(id);
        SetPort(window);
        close_hides_window := true;
        AppleGuideWindowType := agwtAbout;
        thanks_click_count := 0;
        SetMyFont(MFT_Geneva12);
        GetWTitle(window, s);
        GetVersion(app_resfile, vers);
        SPrintS3(s, s, vers.name, '', '');
        SetWTitle(window, s);
        HandleAllUserItems;
    end;

    procedure DoAbout;
    begin
        Inc(thanks_click_count);
        if GetWindowVisible(about_object.window) then begin
            if FrontWindow <> about_object.window then begin
                SelectWindow(about_object.window);
            end;
        end else begin
            SelectWindow(about_object.window);
            ShowWindow(about_object.window);
        end;
    end;

    function AboutEnabled: boolean;
    begin
        AboutEnabled := not IsWObjectFront(about_object);
    end;

    procedure UpdateAboutBox;
    begin
        AssertDidStartup( startup_check );
        SetPort(about_object.window);
        InvalRect(about_object.window^.portRect);
    end;

    procedure CloseAboutBox;
    begin
        AssertDidStartup( startup_check );
        about_object.DoClose;
    end;

    procedure OpenAboutBox;
    begin
        AssertDidStartup( startup_check );
        DoAbout;
        SetPort(about_object.window);
        DrawDialog(about_object.window);
        ValidRect(about_object.window^.portRect);
    end;

    function InitAbout(var msg: integer): OSStatus;
        var
            err: OSErr;

    begin
{$unused(msg)}
        AssertDidStartup( startup_check );
        err := MGetAboutData;
        if err = noErr then begin
            SetRecordedMenuCommand( kAECoreSuite, kAEAbout, Cabout, AboutEnabled, DoAbout );
            if gGetAboutString = nil then begin
                gGetAboutString := DefaultGetAboutString;
            end;
            new(about_object);
            about_object.Create(about_id);
{$ifc do_debug}
            ValidateAboutEntryData;
{$endc}
        end;
        InitAbout := err;
    end;

    procedure ConfigureAbout( get_about_string_proc: GetAboutStringProc );
    begin
        StartupAbout;
        gGetAboutString := get_about_string_proc;
        DidStartup( startup_check );
    end;

    procedure StartupAbout;
    begin
        StartupDialogs;
        StartupFMenus;
        StartupMainLoop;
        StartupOOMenus;
        StartupInternetConfig;
        StartupRecordedMenuCommands;
        SetStartup(InitAbout, nil, 0, nil);
    end;

end.